home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / TURBOPASCAL WIN / WINDEMOS.PAK / DIRDEMO.PAS next >
Pascal/Delphi Source File  |  1992-06-08  |  4KB  |  179 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Demo program                                 }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. { This programs demonstrates how to use the WinCrt unit. See
  10.   Chapter 14 in the Programmer's Guide for more details. For
  11.   information on writing more advanced Windows applications, read
  12.   about the ObjectWindows application framework in the Windows
  13.   Programming Guide. }
  14.  
  15. program DirDemo;
  16.  
  17. {$S-}
  18.  
  19. uses WinTypes, WinProcs, WinCrt, WinDos, Strings;
  20.  
  21. const
  22.   MaxDirSize = 512;
  23.   MonthStr: array[1..12, 0..3] of Char = (
  24.     'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
  25.     'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
  26.  
  27. type
  28.   PDirEntry = ^TDirEntry;
  29.   TDirEntry = record
  30.     Attr: Byte;
  31.     Time: Longint;
  32.     Size: Longint;
  33.     Name: array[0..12] of Char;
  34.   end;
  35.   TDirList = array[0..MaxDirSize - 1] of PDirEntry;
  36.  
  37. var
  38.   Count: Integer;
  39.   Path: array[0..fsPathName] of Char;
  40.   DirList: TDirList;
  41.  
  42. function NumStr(N: Integer): PChar;
  43. const
  44.   NumText: array[0..2] of Char = '00';
  45. begin
  46.   NumText[0] := Chr(N div 10 + Ord('0'));
  47.   NumText[1] := Chr(N mod 10 + Ord('0'));
  48.   NumStr := NumText;
  49. end;
  50.  
  51. procedure QuickSort(L, R: Integer);
  52. var
  53.   I, J: Integer;
  54.   X, Y: PDirEntry;
  55. begin
  56.   I := L;
  57.   J := R;
  58.   X := DirList[(L + R) div 2];
  59.   repeat
  60.     while StrComp(DirList[I]^.Name, X^.Name) < 0 do Inc(I);
  61.     while StrComp(DirList[J]^.Name, X^.Name) > 0 do Dec(J);
  62.     if I <= J then
  63.     begin
  64.       Y := DirList[I];
  65.       DirList[I] := DirList[J];
  66.       DirList[J] := Y;
  67.       Inc(I);
  68.       Dec(J);
  69.     end;
  70.   until I > J;
  71.   if L < J then QuickSort(L, J);
  72.   if I < R then QuickSort(I, R);
  73. end;
  74.  
  75. procedure GetPath;
  76. var
  77.   Attr: Word;
  78.   Dir: array[0..fsDirectory] of Char;
  79.   Name: array[0..fsFileName] of Char;
  80.   Ext: array[0..fsExtension] of Char;
  81.   F: File;
  82. begin
  83.   Write('Show directory of? ');
  84.   ReadLn(Path);
  85.   FileExpand(Path, Path);
  86.   if Path[StrLen(Path) - 1] <> '\' then
  87.   begin
  88.     Assign(F, Path);
  89.     GetFAttr(F, Attr);
  90.     if (DosError = 0) and (Attr and faDirectory <> 0) then
  91.       StrLCat(Path, '\', fsPathName);
  92.   end;
  93.   FileSplit(Path, Dir, Name, Ext);
  94.   if Name[0] = #0 then StrCopy(Name, '*');
  95.   if Ext[0] = #0 then StrCopy(Ext, '.*');
  96.   StrECopy(StrECopy(StrECopy(Path, Dir), Name), Ext);
  97. end;
  98.  
  99. procedure FindFiles;
  100. var
  101.   N: Word;
  102.   SearchRec: TSearchRec;
  103. begin
  104.   Count := 0;
  105.   FindFirst(Path, faReadOnly + faDirectory + faArchive, SearchRec);
  106.   while (DosError = 0) and (Count < MaxDirSize) do
  107.   begin
  108.     N := StrLen(SearchRec.Name) + 10;
  109.     GetMem(DirList[Count], N);
  110.     Move(SearchRec.Attr, DirList[Count]^, N);
  111.     Inc(Count);
  112.     FindNext(SearchRec);
  113.   end;
  114. end;
  115.  
  116. procedure SortFiles;
  117. begin
  118.   if Count <> 0 then QuickSort(0, Count - 1);
  119. end;
  120.  
  121. procedure PrintFiles;
  122. var
  123.   I: Integer;
  124.   Total: Longint;
  125.   P: PChar;
  126.   T: TDateTime;
  127.   N: array[0..fsFileName] of Char;
  128.   E: array[0..fsExtension] of Char;
  129. begin
  130.   WriteLn('Directory of ', Path);
  131.   if Count = 0 then
  132.   begin
  133.     WriteLn('No matching files');
  134.     Exit;
  135.   end;
  136.   Total := 0;
  137.   for I := 0 to Count - 1 do
  138.     with DirList[I]^ do
  139.     begin
  140.       P := StrPos(Name, '.');
  141.       if (P = nil) or (P = Name) then
  142.       begin
  143.         StrCopy(N, Name);
  144.         StrCopy(E, '');
  145.       end else
  146.       begin
  147.         StrLCopy(N, Name, P - Name);
  148.         StrCopy(E, P + 1);
  149.       end;
  150.       Write(N, ' ': 9 - StrLen(N), E, ' ': 4 - StrLen(E));
  151.       if Attr and faDirectory <> 0 then
  152.         Write('<DIR>   ')
  153.       else
  154.         Write(Size: 8);
  155.       UnpackTime(Time, T);
  156.       WriteLn(T.Day: 4, '-',
  157.         MonthStr[T.Month], '-',
  158.         NumStr(T.Year mod 100),
  159.         T.Hour: 4, ':',
  160.         NumStr(T.Min));
  161.       Inc(Total, Size);
  162.     end;
  163.   WriteLn(Count, ' files, ', Total, ' bytes, ',
  164.     DiskFree(Ord(Path[0]) - 64), ' bytes free');
  165.   WriteLn;
  166. end;
  167.  
  168. begin
  169.   ScreenSize.X := 64;
  170.   ScreenSize.Y := 256;
  171.   while True do
  172.   begin
  173.     GetPath;
  174.     FindFiles;
  175.     SortFiles;
  176.     PrintFiles;
  177.   end;
  178. end.
  179.